Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH3/SRC/PALEDIT.FRM

Text File | 1997-01-03 | 42KB | 1,449 lines

VERSION 4.00
Begin VB.Form PalEditForm
   Caption         =   "PalEdit"
   ClientHeight    =   5805
   ClientLeft      =   1305
   ClientTop       =   780
   ClientWidth     =   7020
   Height          =   6495
   Left            =   1245
   LinkTopic       =   "Form1"
   ScaleHeight     =   388
   ScaleMode       =   0  'User
   ScaleWidth      =   468
   Top             =   150
   Width           =   7140
   Begin VB.PictureBox ColorSwatch
      AutoRedraw      =   -1  'True
      Height          =   2280
      Left            =   4560
      Picture         =   "PALEDIT.frx":0000
      ScaleHeight     =   2220
      ScaleWidth      =   2400
      TabIndex        =   15
      Top             =   2505
      Width           =   2460
   End
   Begin VB.PictureBox SystemColors
      AutoRedraw      =   -1  'True
      Height          =   2460
      Left            =   4560
      Picture         =   "PALEDIT.frx":0446
      ScaleHeight     =   160
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   160
      TabIndex        =   14
      Top             =   0
      Width           =   2460
   End
   Begin VB.PictureBox ColorBox
      BorderStyle     =   0  'None
      Height          =   975
      Left            =   0
      ScaleHeight     =   65
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   468
      TabIndex        =   4
      Top             =   4830
      Width           =   7020
      Begin VB.HScrollBar BlueScroll
         Enabled         =   0   'False
         Height          =   255
         LargeChange     =   16
         Left            =   885
         Max             =   255
         TabIndex        =   7
         Top             =   720
         Width           =   6090
      End
      Begin VB.HScrollBar GreenScroll
         Enabled         =   0   'False
         Height          =   255
         LargeChange     =   16
         Left            =   885
         Max             =   255
         TabIndex        =   6
         Top             =   360
         Width           =   6090
      End
      Begin VB.HScrollBar RedScroll
         Enabled         =   0   'False
         Height          =   255
         LargeChange     =   16
         Left            =   885
         Max             =   255
         TabIndex        =   5
         Top             =   0
         Width           =   6090
      End
      Begin VB.Label BlueLabel
         BorderStyle     =   1  'Fixed Single
         Caption         =   "0"
         Height          =   255
         Left            =   480
         TabIndex        =   13
         Top             =   720
         Width           =   375
      End
      Begin VB.Label GreenLabel
         BorderStyle     =   1  'Fixed Single
         Caption         =   "0"
         Height          =   255
         Left            =   480
         TabIndex        =   12
         Top             =   360
         Width           =   375
      End
      Begin VB.Label RedLabel
         BorderStyle     =   1  'Fixed Single
         Caption         =   "0"
         Height          =   255
         Left            =   480
         TabIndex        =   11
         Top             =   0
         Width           =   375
      End
      Begin VB.Label Label1
         Caption         =   "Red"
         Height          =   255
         Index           =   2
         Left            =   0
         TabIndex        =   10
         Top             =   0
         Width           =   495
      End
      Begin VB.Label Label1
         Caption         =   "Green"
         Height          =   255
         Index           =   1
         Left            =   0
         TabIndex        =   9
         Top             =   360
         Width           =   495
      End
      Begin VB.Label Label1
         Caption         =   "Blue"
         Height          =   255
         Index           =   0
         Left            =   0
         TabIndex        =   8
         Top             =   720
         Width           =   495
      End
   End
   Begin VB.PictureBox HiddenPict
      AutoRedraw      =   -1  'True
      Height          =   495
      Left            =   3720
      Picture         =   "PALEDIT.frx":088C
      ScaleHeight     =   29
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   29
      TabIndex        =   0
      Top             =   4560
      Visible         =   0   'False
      Width           =   495
   End
   Begin VB.HScrollBar HBar
      Height          =   255
      Left            =   0
      TabIndex        =   3
      Top             =   4530
      Width           =   4245
   End
   Begin VB.VScrollBar VBar
      Height          =   4515
      Left            =   4260
      TabIndex        =   2
      Top             =   0
      Width           =   255
   End
   Begin VB.PictureBox ImagePict
      AutoRedraw      =   -1  'True
      Height          =   4515
      Left            =   0
      MousePointer    =   2  'Cross
      Picture         =   "PALEDIT.frx":0CD2
      ScaleHeight     =   297
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   279
      TabIndex        =   1
      Top             =   0
      Width           =   4245
   End
   Begin MSComDlg.CommonDialog FileDialog
      Left            =   4200
      Top             =   4560
      _Version        =   65536
      _ExtentX        =   847
      _ExtentY        =   847
      _StockProps     =   0
      CancelError     =   -1  'True
      FontSize        =   8.37851e-39
   End
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      Begin VB.Menu mnuFileLoad
         Caption         =   "&Load..."
         Shortcut        =   ^L
      End
      Begin VB.Menu mnuFileSave
         Caption         =   "&Save"
         Enabled         =   0   'False
         Shortcut        =   ^S
      End
      Begin VB.Menu mnuFileSaveAs
         Caption         =   "Save &As..."
         Shortcut        =   ^A
      End
      Begin VB.Menu mnuFileSep1
         Caption         =   "-"
      End
      Begin VB.Menu mnuFileRevert
         Caption         =   "&Revert"
         Enabled         =   0   'False
         Shortcut        =   ^R
      End
      Begin VB.Menu mnuFileSep2
         Caption         =   "-"
      End
      Begin VB.Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
   Begin VB.Menu mnuScale
      Caption         =   "&Scale"
      Begin VB.Menu mnuScaleZoomIn
         Caption         =   "Zoom &In"
         Shortcut        =   ^I
      End
      Begin VB.Menu mnuScaleFull
         Caption         =   "&Full Scale"
      End
      Begin VB.Menu mnuScaleZoomOut
         Caption         =   "Zoom &Out"
         Shortcut        =   ^O
      End
   End
   Begin VB.Menu mnuColor
      Caption         =   "&Color"
      Begin VB.Menu mnuNear
         Caption         =   "&Nearest"
         Begin VB.Menu mnuNearRed
            Caption         =   "&Red"
         End
         Begin VB.Menu mnuNearGreen
            Caption         =   "&Green"
         End
         Begin VB.Menu mnuNearBlue
            Caption         =   "&Blue"
         End
         Begin VB.Menu mnuNearGray
            Caption         =   "Gray"
         End
      End
      Begin VB.Menu mnuGrad
         Caption         =   "&Gradient"
         Begin VB.Menu mnuGradRed
            Caption         =   "&Red"
         End
         Begin VB.Menu mnuGradGreen
            Caption         =   "&Green"
         End
         Begin VB.Menu mnuGradBlue
            Caption         =   "&Blue"
         End
         Begin VB.Menu mnuGradGray
            Caption         =   "Gray"
         End
         Begin VB.Menu mnuGradRainbow
            Caption         =   "Rainbow"
         End
      End
   End
End
Attribute VB_Name = "PalEditForm"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit

Const NO_COLOR = -1

Dim LogicalPalette As Long
Dim SystemPalette As Long

Dim SysPalSize As Integer
Dim NumStaticColors As Integer
Dim StaticColor1 As Integer
Dim StaticColor2 As Integer

Dim SelectedI As Integer
Dim SelectedJ As Integer
Dim SelectedColor As Integer
Dim SelectedR As Integer
Dim SelectedG As Integer
Dim SelectedB As Integer

Dim Dx As Integer
Dim Dy As Integer
Dim SWid As Single
Dim SHgt As Single
Dim IWid As Single
Dim IHgt As Single
Dim ImageScale As Single

Dim SettingColor As Boolean
Dim DataChanged As Boolean
Dim FileLoaded As String
' ***********************************************
' If the data has been modified, allow the user
' to save the changes or cancel the operation.
' Return True if:
'
'   - The image data has not been changed since
'       it was loaded.
'   - The user saves the changes.
'   - The user says not to save.
'
' Return False otherwise.
' ***********************************************
Function DataSafe() As Boolean
    DataSafe = True

    ' This is done in a while loop in case the
    ' user starts a save and then cancels.
    Do While DataChanged
        Select Case MsgBox("The data has been modified. Do you want to save the changes?", vbQuestion + vbYesNoCancel, "Data Modified")
            Case vbYes
                If FileLoaded <> "" Then
                    mnuFileSave_Click
                Else
                    mnuFileSaveAs_Click
                End If
                DataSafe = Not DataChanged

            Case vbNo
                DataSafe = True
                Exit Do

            Case vbCancel
                DataSafe = False
                Exit Do
        End Select
    Loop
End Function

' ***********************************************
' Copy the image from HiddenPict to ImagePict at
' the correct scale.
' ***********************************************
Sub DrawImage()
Dim image_wid As Single
Dim image_hgt As Single
Dim hidden_wid As Single
Dim hidden_hgt As Single

    If Not Visible Then Exit Sub

    ' Fill it with white. Cls would redisplay the
    ' Picture which is bad if ImageScale < 1.
    ImagePict.Line (0, 0)-(IWid, IHgt), vbWhite, BF

    ' Copy the picture at the correct scale.
    image_wid = ImagePict.ScaleWidth
    image_hgt = ImagePict.ScaleHeight
    hidden_wid = image_wid / ImageScale
    hidden_hgt = image_hgt / ImageScale
    ImagePict.PaintPicture _
        HiddenPict.Picture, 0, 0, _
        image_wid, image_hgt, _
        HBar.Value, VBar.Value, _
        hidden_wid, hidden_hgt
End Sub

' ***********************************************
' Load the indicated file and prepare to work
' with its palette.
' ***********************************************
Sub LoadImagePict(fname As String)
    On Error GoTo LoadFileError
    HiddenPict.Picture = LoadPicture(fname)
    ImageScale = 1#
    ResetScrollBars

    On Error GoTo LoadPalError
    LoadLogicalPalette

    FileLoaded = fname
    Caption = "PalEdit [" & fname & "]"
    mnuFileSave.Enabled = True
    mnuFileRevert.Enabled = True
    DataChanged = False
    Exit Sub

LoadFileError:
    Beep
    MsgBox "Error loading file " & fname & "." & _
        vbCrLf & Error$
    Exit Sub

LoadPalError:
    Beep
    MsgBox "Error loading logical palette." & _
        vbCrLf & Error$
    Exit Sub
End Sub

' ***********************************************
' Set the Max and LargeChange properties for the
' image scroll bars.
' ***********************************************
Sub ResetScrollBars()
Dim change As Single

    change = ImagePict.ScaleWidth / ImageScale
    If HiddenPict.ScaleWidth <= change Then
        HBar.Value = 0
        HBar.Enabled = False
    Else
        HBar.Max = HiddenPict.ScaleWidth - change
        HBar.LargeChange = change
        HBar.Enabled = True
    End If

    change = ImagePict.ScaleHeight / ImageScale
    If HiddenPict.ScaleHeight <= change Then
        VBar.Value = 0
        VBar.Enabled = False
    Else
        VBar.Max = HiddenPict.ScaleHeight - change
        VBar.LargeChange = change
        VBar.Enabled = True
    End If
End Sub

' ***********************************************
' Select the color with the indicated index.
' ***********************************************
Sub SelectColorIndex(ByVal index As Integer)
Dim i As Integer
Dim j As Integer

    i = index \ 16
    j = index Mod 16
    SelectColor i, j
End Sub

' ***********************************************
' Give the form and all the picture boxes an
' hourglass cursor.
' ***********************************************
Sub WaitStart()
    MousePointer = vbHourglass
    SystemColors.MousePointer = vbHourglass
    ImagePict.MousePointer = vbHourglass
    ColorSwatch.MousePointer = vbHourglass
    DoEvents
End Sub


' ***********************************************
' Restore the mouse pointers for the form and all
' the picture boxes.
' ***********************************************
Sub WaitEnd()
    MousePointer = vbDefault
    SystemColors.MousePointer = vbDefault
    ImagePict.MousePointer = vbCrosshair
    ColorSwatch.MousePointer = vbDefault
End Sub

' ***********************************************
' Load the HiddenPict palette so its entries
' match the system entries.
' ***********************************************
Sub LoadLogicalPalette()
Dim palentry(0 To 255) As PALETTEENTRY
Dim blanked(0 To 255) As PALETTEENTRY
Dim i As Integer

    ' Make ImagePict and ColorSwatch use the same
    ' palette as HiddenPict.
    ImagePict.Picture = HiddenPict.Picture
    ColorSwatch.Picture = HiddenPict.Picture
    LogicalPalette = HiddenPict.Picture.hPal

    ' Draw the image at the correct scale.
    DrawImage

    ' Make sure ImagePict has the foreground palette.
    i = RealizePalette(ImagePict.hdc)

    ' Give the system a chance to catch up.
    DoEvents

    ' Make the logical palette as big as possible.
    If ResizePalette(LogicalPalette, SysPalSize) = 0 Then
        Beep
        MsgBox "Error resizing logical palette.", _
            vbExclamation
        Exit Sub
    End If

    ' Get the system palette entries.
    i = GetSystemPaletteEntries(HiddenPict.hdc, 0, SysPalSize, palentry(0))

    ' Blank the non-static colors.
    For i = 0 To StaticColor1
        blanked(i) = palentry(i)
    Next i
    For i = StaticColor1 + 1 To StaticColor2 - 1
        With blanked(i)
            .peRed = 0
            .peGreen = 0
            .peBlue = 0
            .peFlags = PC_NOCOLLAPSE
        End With
    Next i
    For i = StaticColor2 To 255
        blanked(i) = palentry(i)
    Next i
    i = SetPaletteEntries(LogicalPalette, 0, SysPalSize, blanked(0))

    ' Insert the non-static colors.
    For i = StaticColor1 + 1 To StaticColor2 - 1
        palentry(i).peFlags = PC_NOCOLLAPSE
    Next i
    i = SetPaletteEntries(LogicalPalette, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, palentry(StaticColor1 + 1))

    ' Realize the new palette values.
    i = RealizePalette(ImagePict.hdc)

    ' Select the color that was selected before.
    SelectColor SelectedI, SelectedJ
End Sub

' ***********************************************
' Load the SystemColors palette with PC_EXPLICIT
' entries so they match the system palette.
' ***********************************************
Sub LoadSystemPalette()
Dim palentry(0 To 255) As PALETTEENTRY
Dim i As Integer

    ' Make the logical palette as big as possible.
    SystemPalette = SystemColors.Picture.hPal
    If ResizePalette(SystemPalette, SysPalSize) = 0 Then
        Beep
        MsgBox "Error resizing system palette.", _
            vbExclamation
        Exit Sub
    End If

    ' Flag all palette entries as PC_EXPLICIT.
    ' Set peRed to the system palette indexes.
    For i = 0 To SysPalSize - 1
        palentry(i).peRed = i
        palentry(i).peFlags = PC_EXPLICIT
    Next i

    ' Update the palette (ignore return value).
    i = SetPaletteEntries(SystemPalette, 0, SysPalSize, palentry(0))
End Sub


' ***********************************************
' Fill the system picture with all the palette
' colors, hatching the static colors.
' ***********************************************
Sub ShowSystemColors()
Dim i As Integer
Dim j As Integer
Dim clr As Integer
Dim oldfill As Integer
Dim olddraw As Integer

    SystemColors.Cls

    ' Display the colors using palette indexing.
    Dx = SystemColors.ScaleWidth / 16
    Dy = SystemColors.ScaleHeight / 16
    clr = 0
    For i = 0 To 15
        For j = 0 To 15
            SystemColors.Line _
                (j * Dx, i * Dy)-Step(Dx, Dy), _
                clr + &H1000000, BF
            clr = clr + 1
        Next j
    Next i

    ' Hatch the static colors.
    oldfill = SystemColors.FillStyle
    olddraw = SystemColors.DrawMode
    SystemColors.FillStyle = vbDownwardDiagonal
    SystemColors.DrawMode = vbInvisible

    SystemColors.Line (0, 0)-Step((NumStaticColors \ 2) * Dx - 1, Dy - 1), , B
    SystemColors.Line (16 * Dx, 16 * Dy)-Step(-(NumStaticColors \ 2) * Dx, -Dy), , B

    SystemColors.FillStyle = oldfill
    SystemColors.DrawMode = olddraw

    ' Highlight color (0, 0).
    SelectedColor = NO_COLOR
    SelectColor 0, 0
End Sub

' ***********************************************
' Select the color at the indicated position.
' ***********************************************
Sub SelectColor(ByVal i As Integer, ByVal j As Integer)
Const GAP1 = 1
Const GAP2 = 2
Const DRAW_WID = 2

Dim oldmode As Integer
Dim oldwid As Integer

    oldmode = SystemColors.DrawMode
    oldwid = SystemColors.DrawWidth
    SystemColors.DrawMode = vbInvert
    SystemColors.DrawWidth = DRAW_WID

    ' Unhighlight the previously selected color.
    If SelectedColor <> NO_COLOR Then _
        SystemColors.Line (SelectedJ * Dx + GAP1, SelectedI * Dx + GAP1)-Step(Dx - GAP2, Dx - GAP2), , B

    ' Record the new color.
    SelectedI = i
    SelectedJ = j
    SelectedColor = i * 16 + j

    ' Highlight the new color.
    SystemColors.Line (SelectedJ * Dx + GAP1, SelectedI * Dx + GAP1)-Step(Dx - GAP2, Dx - GAP2), , B
    SystemColors.DrawMode = oldmode
    SystemColors.DrawWidth = oldwid

    ' Display the color's components.
    ShowColorValue
End Sub


' ***********************************************
' Display the selected color's components in the
' colors labels and scroll bars.
' ***********************************************
Sub ShowColorValue()
Dim palentry As PALETTEENTRY
Dim status As Integer

    If SelectedColor = NO_COLOR Then Exit Sub

    status = GetSystemPaletteEntries(SystemColors.hdc, SelectedColor, 1, palentry)

    ' Update the labels.
    RedLabel.Caption = Format$(palentry.peRed)
    GreenLabel.Caption = Format$(palentry.peGreen)
    BlueLabel.Caption = Format$(palentry.peBlue)

    ' Update the color swatch.
    ColorSwatch.Line (0, 0)-(SWid, SHgt), RGB(palentry.peRed, palentry.peGreen, palentry.peBlue), BF

    ' Update the scroll bars.
    If SelectedColor > StaticColor1 And SelectedColor < StaticColor2 Then
        SettingColor = True
        RedScroll.Value = palentry.peRed
        GreenScroll.Value = palentry.peGreen
        BlueScroll.Value = palentry.peBlue
        SettingColor = False
        RedScroll.Enabled = True
        GreenScroll.Enabled = True
        BlueScroll.Enabled = True
    Else
        RedScroll.Enabled = False
        GreenScroll.Enabled = False
        BlueScroll.Enabled = False
    End If
End Sub


' ***********************************************
' Update the selected color's value.
' ***********************************************
Sub UpdatePalette()
Dim pe As PALETTEENTRY
Dim i As Integer

    pe.peRed = RedScroll.Value
    pe.peGreen = GreenScroll.Value
    pe.peBlue = BlueScroll.Value
    pe.peFlags = PC_NOCOLLAPSE

    i = SetPaletteEntries(LogicalPalette, SelectedColor, 1, pe)
    i = RealizePalette(HiddenPict.hdc)

    ColorSwatch.Line (0, 0)-(SWid, SHgt), RGB(pe.peRed, pe.peGreen, pe.peBlue), BF

    DataChanged = True
End Sub




' ***********************************************
' Update the selected color's value.
' ***********************************************
Private Sub BlueScroll_Change()
    If SettingColor Then Exit Sub
    BlueLabel.Caption = Format$(BlueScroll.Value)
    UpdatePalette
End Sub


' ***********************************************
' Update the selected color's value.
' ***********************************************
Private Sub BlueScroll_Scroll()
    If SettingColor Then Exit Sub
    BlueLabel.Caption = Format$(BlueScroll.Value)
    UpdatePalette
End Sub


' ***********************************************
' Make the scroll bars as big as possible within
' ColorBox.
' ***********************************************
Private Sub ColorBox_Resize()
Dim wid As Single

    wid = ColorBox.ScaleWidth - RedLabel.Left - RedLabel.Width - 2
    If wid < 10 Then wid = 10
    RedScroll.Width = wid
    GreenScroll.Width = wid
    BlueScroll.Width = wid
End Sub


' ***********************************************
' 1. Make sure we can handle palettes.
' 2. Find out how big the system palette is and how
' many static colors there are.
' 3. Load and display the system palette.
' ***********************************************
Private Sub Form_Load()
    ' Make sure the screen supports palettes.
    If Not GetDeviceCaps(hdc, RASTERCAPS) And RC_PALETTE Then
        Beep
        MsgBox "This monitor does not support palettes.", _
            vbCritical
        End
    End If

    ' get system palette size and # static colors.
    SysPalSize = GetDeviceCaps(hdc, SIZEPALETTE)
    NumStaticColors = GetDeviceCaps(hdc, NUMRESERVED)
    StaticColor1 = NumStaticColors \ 2 - 1
    StaticColor2 = SysPalSize - NumStaticColors \ 2

    HiddenPict.AutoSize = True
    ImageScale = 1#

    ' Load the system palette.
    LoadSystemPalette

    ' Display the system palette.
    ShowSystemColors

    ' Load the logical palette.
    LoadLogicalPalette
End Sub

' ***********************************************
' Refuse to unload if there are unsaved changes.
' ***********************************************
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Cancel = Not DataSafe()
End Sub


' ***********************************************
' Make the picture as large as possible.
' ***********************************************
Private Sub Form_Resize()
Dim L As Single
Dim T As Single
Dim wid As Single
Dim hgt As Single

    If WindowState = vbMinimized Then Exit Sub

    ' Keep system colors in the upper right corner.
    SystemColors.Move ScaleWidth - SystemColors.Width

    ' Keep color box stretched across the bottom.
    ColorBox.Move 0, ScaleHeight - ColorBox.Height, ScaleWidth

    ' Put color swatch under system colors.
    hgt = ColorBox.Top - SystemColors.Height - 6
    If hgt < 10 Then hgt = 10
    ColorSwatch.Move SystemColors.Left, SystemColors.Height + 3, ColorSwatch.Width, hgt
    SWid = ColorSwatch.ScaleWidth - 1
    SHgt = ColorSwatch.ScaleHeight - 1

    ' Place the vertical scroll bar.
    L = SystemColors.Left - VBar.Width - 3
    hgt = ColorBox.Top - HBar.Height - 4
    If hgt < 10 Then hgt = 10
    VBar.Move L, 0, VBar.Width, hgt

    ' Place the horizontal scroll bar.
    T = ColorBox.Top - HBar.Height - 3
    wid = SystemColors.Left - VBar.Width - 4
    If wid < 10 Then wid = 10
    HBar.Move 0, T, wid

    ' Place ImagePict inside the scroll bars.
    ImagePict.Move 0, 0, wid, hgt
    IWid = ImagePict.ScaleWidth - 1
    IHgt = ImagePict.ScaleHeight - 1

    ' Set the scroll bar limits.
    ResetScrollBars

    ' Redraw the image in case we've grown.
    DrawImage

    ' Refill ColorSwatch (it may have grown).
    ShowColorValue
End Sub


Private Sub Form_Unload(Cancel As Integer)
    End
End Sub

' ***********************************************
' Update the selected color's value.
' ***********************************************
Private Sub GreenScroll_Change()
    If SettingColor Then Exit Sub
    GreenLabel.Caption = Format$(GreenScroll.Value)
    UpdatePalette
End Sub

' ***********************************************
' Update the selected color's value.
' ***********************************************
Private Sub GreenScroll_Scroll()
    If SettingColor Then Exit Sub
    GreenLabel.Caption = Format$(GreenScroll.Value)
    UpdatePalette
End Sub

' ***********************************************
' Redraw the image scrolled appropriately.
' ***********************************************
Private Sub HBar_Change()
    DrawImage
End Sub

' ***********************************************
' Redraw the image scrolled appropriately.
' ***********************************************
Private Sub HBar_Scroll()
    DrawImage
End Sub


' ***********************************************
' Select the color the user clicked on.
' ***********************************************
Private Sub ImagePict_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim bm As BITMAP
Dim hbm As Integer
Dim status As Long
Dim bytes() As Byte
Dim wid As Long
Dim hgt As Long

    ' Get a handle to the bitmap.
    hbm = ImagePict.Image

    ' See how big it is.
    status = GetObject(hbm, BITMAP_SIZE, bm)
    wid = bm.bmWidthBytes
    hgt = bm.bmHeight

    ' If the mouse is out of bounds, bail out.
    If X >= wid Or Y >= hgt Then
        Beep
        Exit Sub
    End If

    ' Get the bits.
    ReDim bytes(0 To wid - 1, 0 To hgt - 1)
    status = GetBitmapBits(hbm, wid * hgt, bytes(0, 0))

    ' Select the color of this pixel.
    SelectColorIndex bytes(CInt(X), CInt(Y))
End Sub


' ***********************************************
' Load a new image file.
' ***********************************************
Private Sub mnuFileLoad_Click()
Dim fname As String

    ' Make sure any changes have been saved.
    If Not DataSafe() Then Exit Sub

    ' Allow the user to pick a file.
    On Error Resume Next
    FileDialog.filename = "*.BMP;*.ICO;*.RLE;*.WMF;*.DIB"
    FileDialog.Flags = cdlOFNFileMustExist + cdlOFNHideReadOnly
    FileDialog.ShowOpen
    If Err.Number = cdlCancel Then
        Exit Sub
    ElseIf Err.Number <> 0 Then
        Beep
        MsgBox "Error selecting file.", , vbExclamation
        Exit Sub
    End If
    On Error GoTo 0

    fname = Trim$(FileDialog.filename)
    FileDialog.InitDir = Left$(fname, Len(fname) _
        - Len(FileDialog.FileTitle) - 1)

    ' Load the picture.
    WaitStart
    DoEvents
    LoadImagePict fname
    WaitEnd
End Sub

' ***********************************************
' Reload the file.
' ***********************************************
Private Sub mnuFileRevert_Click()
    ' If the data has changed, get confirmation.
    If DataChanged Then
        If MsgBox("The data has been modified. Are you sure you want to remove the changes?", _
            vbQuestion + vbYesNo) = vbNo Then _
                Exit Sub
    End If

    ' Reload the picture.
    WaitStart
    DoEvents
    LoadImagePict FileLoaded
    WaitEnd
End Sub

' ***********************************************
' Save the image in the file from which it was
' loaded.
' ***********************************************
Private Sub mnuFileSave_Click()
    WaitStart
    DoEvents
    SaveImagePict FileLoaded
    WaitEnd
End Sub

' ***********************************************
' Save the image in a new file.
' ***********************************************
Private Sub mnuFileSaveAs_Click()
Dim fname As String

    ' Allow the user to pick a file.
    On Error Resume Next
    FileDialog.filename = "*.BMP;*.ICO;*.RLE;*.WMF;*.DIB"
    FileDialog.Flags = cdlOFNOverwritePrompt + _
        cdlOFNHideReadOnly + cdlOFNPathMustExist
    FileDialog.ShowSave
    If Err.Number = cdlCancel Then
        Exit Sub
    ElseIf Err.Number <> 0 Then
        Beep
        MsgBox "Error selecting file.", , vbExclamation
        Exit Sub
    End If
    On Error GoTo 0

    fname = Trim$(FileDialog.filename)
    FileDialog.InitDir = Left$(fname, Len(fname) _
        - Len(FileDialog.FileTitle) - 1)

    ' Save the picture.
    WaitStart
    DoEvents
    SaveImagePict fname
    WaitEnd
End Sub


' ***********************************************
' Save the picture in the indicated file.
' ***********************************************
Sub SaveImagePict(fname As String)
    On Error GoTo SaveError
    SavePicture HiddenPict.Picture, fname

    Caption = "PalEdit [" & fname & "]"
    FileLoaded = fname
    DataChanged = False
    Exit Sub

SaveError:
    Beep
    MsgBox "Error saving picture in file " & _
        fname & "." & vbCrLf & vbCrLf & _
        Error$, , vbExclamation
    Exit Sub

End Sub


' ***********************************************
' Replace colors with a green gradient.
' ***********************************************
Private Sub mnuGradGreen_Click()
Dim palentry(0 To 255) As PALETTEENTRY
Dim i As Integer
Dim g As Single
Dim Dg As Single

    Dg = 255 / (StaticColor2 - StaticColor1)
    g = Dg
    For i = StaticColor1 + 1 To StaticColor2 - 1
        With palentry(i)
            .peRed = 0
            .peGreen = g
            .peBlue = 0
            .peFlags = PC_NOCOLLAPSE
        End With
        g = g + Dg
    Next i
    If SetPaletteEntries(LogicalPalette, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, palentry(StaticColor1 + 1)) = 0 Then
        Beep
        MsgBox "Error resetting colors.", , vbExclamation
        Exit Sub
    End If
    i = RealizePalette(ImagePict.hdc)
    DataChanged = True
End Sub

' ***********************************************
' Replace colors with red, green, and blue
' gradients.
' ***********************************************
Private Sub mnuGradRainbow_Click()
Dim palentry(0 To 255) As PALETTEENTRY
Dim i As Integer
Dim num_each As Integer
Dim clr As Integer
Dim c As Single
Dim Dc As Single

    num_each = (StaticColor2 - StaticColor1) / 3
    Dc = 255 / num_each
    clr = StaticColor1 + 1

    ' Red shades.
    c = Dc
    For i = 1 To num_each
        With palentry(clr)
            .peRed = c
            .peGreen = 0
            .peBlue = 0
            .peFlags = PC_NOCOLLAPSE
        End With
        c = c + Dc
        clr = clr + 1
    Next i

    ' Green shades.
    c = Dc
    For i = 1 To num_each
        With palentry(clr)
            .peRed = 0
            .peGreen = c
            .peBlue = 0
            .peFlags = PC_NOCOLLAPSE
        End With
        c = c + Dc
        clr = clr + 1
    Next i

    ' Blue shades.
    c = Dc
    For i = clr To StaticColor2 - 1
        With palentry(clr)
            .peRed = 0
            .peGreen = 0
            .peBlue = c
            .peFlags = PC_NOCOLLAPSE
        End With
        c = c + Dc
        clr = clr + 1
    Next i

    If SetPaletteEntries(LogicalPalette, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, palentry(StaticColor1 + 1)) = 0 Then
        Beep
        MsgBox "Error resetting colors.", , vbExclamation
        Exit Sub
    End If
    i = RealizePalette(ImagePict.hdc)
    DataChanged = True
End Sub

' ***********************************************
' Replace colors with a red gradient.
' ***********************************************
Private Sub mnuGradRed_Click()
Dim palentry(0 To 255) As PALETTEENTRY
Dim i As Integer
Dim r As Single
Dim Dr As Single

    Dr = 255 / (StaticColor2 - StaticColor1)
    r = Dr
    For i = StaticColor1 + 1 To StaticColor2 - 1
        With palentry(i)
            .peRed = r
            .peGreen = 0
            .peBlue = 0
            .peFlags = PC_NOCOLLAPSE
        End With
        r = r + Dr
    Next i
    If SetPaletteEntries(LogicalPalette, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, palentry(StaticColor1 + 1)) = 0 Then
        Beep
        MsgBox "Error resetting colors.", , vbExclamation
        Exit Sub
    End If
    i = RealizePalette(ImagePict.hdc)
    DataChanged = True
End Sub
' ***********************************************
' Replace colors with appropriate greens.
' ***********************************************
Private Sub mnuNearGreen_Click()
Dim palentry(0 To 255) As PALETTEENTRY
Dim i As Integer
Dim clr As Integer

    ' Get the current color values.
    i = GetPaletteEntries(LogicalPalette, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, palentry(StaticColor1 + 1))

    ' Fill in the nearest shades.
    For i = StaticColor1 + 1 To StaticColor2 - 1
        With palentry(i)
            clr = (CInt(.peRed) + .peGreen + .peBlue) / 3
            .peRed = 0
            .peGreen = clr
            .peBlue = 0
            .peFlags = PC_NOCOLLAPSE
        End With
    Next i
    If SetPaletteEntries(LogicalPalette, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, palentry(StaticColor1 + 1)) = 0 Then
        Beep
        MsgBox "Error resetting colors.", , vbExclamation
        Exit Sub
    End If
    i = RealizePalette(ImagePict.hdc)
    DataChanged = True
End Sub


' ***********************************************
' Replace colors with appropriate reds.
' ***********************************************
Private Sub mnuNearRed_Click()
Dim palentry(0 To 255) As PALETTEENTRY
Dim i As Integer
Dim clr As Integer

    ' Get the current color values.
    i = GetPaletteEntries(LogicalPalette, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, palentry(StaticColor1 + 1))

    ' Fill in the nearest shades.
    For i = StaticColor1 + 1 To StaticColor2 - 1
        With palentry(i)
            clr = (CInt(.peRed) + .peGreen + .peBlue) / 3
            .peRed = clr
            .peGreen = 0
            .peBlue = 0
            .peFlags = PC_NOCOLLAPSE
        End With
    Next i
    If SetPaletteEntries(LogicalPalette, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, palentry(StaticColor1 + 1)) = 0 Then
        Beep
        MsgBox "Error resetting colors.", , vbExclamation
        Exit Sub
    End If
    i = RealizePalette(ImagePict.hdc)
    DataChanged = True
End Sub



' ***********************************************
' Replace colors with appropriate grays.
' ***********************************************
Private Sub mnuNearGray_Click()
Dim palentry(0 To 255) As PALETTEENTRY
Dim i As Integer
Dim clr As Integer

    ' Get the current color values.
    i = GetPaletteEntries(LogicalPalette, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, palentry(StaticColor1 + 1))

    ' Fill in the nearest shades.
    For i = StaticColor1 + 1 To StaticColor2 - 1
        With palentry(i)
            clr = (CInt(.peRed) + .peGreen + .peBlue) / 3
            .peRed = clr
            .peGreen = clr
            .peBlue = clr
            .peFlags = PC_NOCOLLAPSE
        End With
    Next i
    If SetPaletteEntries(LogicalPalette, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, palentry(StaticColor1 + 1)) = 0 Then
        Beep
        MsgBox "Error resetting colors.", , vbExclamation
        Exit Sub
    End If
    i = RealizePalette(ImagePict.hdc)
    DataChanged = True
End Sub



' ***********************************************
' Replace colors with appropriate blues.
' ***********************************************
Private Sub mnuNearBlue_Click()
Dim palentry(0 To 255) As PALETTEENTRY
Dim i As Integer
Dim clr As Integer

    ' Get the current color values.
    i = GetPaletteEntries(LogicalPalette, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, palentry(StaticColor1 + 1))

    ' Fill in the nearest shades.
    For i = StaticColor1 + 1 To StaticColor2 - 1
        With palentry(i)
            clr = (CInt(.peRed) + .peGreen + .peBlue) / 3
            .peRed = 0
            .peGreen = 0
            .peBlue = clr
            .peFlags = PC_NOCOLLAPSE
        End With
    Next i
    If SetPaletteEntries(LogicalPalette, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, palentry(StaticColor1 + 1)) = 0 Then
        Beep
        MsgBox "Error resetting colors.", , vbExclamation
        Exit Sub
    End If
    i = RealizePalette(ImagePict.hdc)
    DataChanged = True
End Sub



' ***********************************************
' Replace colors with a gray gradient.
' ***********************************************
Private Sub mnuGradGray_Click()
Dim palentry(0 To 255) As PALETTEENTRY
Dim i As Integer
Dim g As Single
Dim Dg As Single

    Dg = 255 / (StaticColor2 - StaticColor1)
    g = Dg
    For i = StaticColor1 + 1 To StaticColor2 - 1
        With palentry(i)
            .peRed = g
            .peGreen = g
            .peBlue = g
            .peFlags = PC_NOCOLLAPSE
        End With
        g = g + Dg
    Next i
    If SetPaletteEntries(LogicalPalette, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, palentry(StaticColor1 + 1)) = 0 Then
        Beep
        MsgBox "Error resetting colors.", , vbExclamation
        Exit Sub
    End If
    i = RealizePalette(ImagePict.hdc)
    DataChanged = True
End Sub


' ***********************************************
' Replace colors with a blue gradient.
' ***********************************************
Private Sub mnuGradBlue_Click()
Dim palentry(0 To 255) As PALETTEENTRY
Dim i As Integer
Dim b As Single
Dim Db As Single

    Db = 255 / (StaticColor2 - StaticColor1)
    b = Db
    For i = StaticColor1 + 1 To StaticColor2 - 1
        With palentry(i)
            .peRed = 0
            .peGreen = 0
            .peBlue = b
            .peFlags = PC_NOCOLLAPSE
        End With
        b = b + Db
    Next i
    If SetPaletteEntries(LogicalPalette, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, palentry(StaticColor1 + 1)) = 0 Then
        Beep
        MsgBox "Error resetting colors.", , vbExclamation
        Exit Sub
    End If
    i = RealizePalette(ImagePict.hdc)
    DataChanged = True
End Sub


' ***********************************************
' Set ImageScale = 1 and redraw the image.
' ***********************************************
Private Sub mnuScaleFull_Click()
    ImageScale = 1#
    ResetScrollBars
    DrawImage
End Sub
' ***********************************************
' Increase ImageScale and redraw the image.
' ***********************************************
Private Sub mnuScaleZoomIn_Click()
    ImageScale = ImageScale * 2#
    ResetScrollBars
    DrawImage
End Sub


' ***********************************************
' Decrease ImageScale and redraw the image.
' ***********************************************
Private Sub mnuScaleZoomOut_Click()
    ImageScale = ImageScale / 2#
    ResetScrollBars
    DrawImage
End Sub


' ***********************************************
' Update the selected color's value.
' ***********************************************
Private Sub RedScroll_Change()
    If SettingColor Then Exit Sub
    RedLabel.Caption = Format$(RedScroll.Value)
    UpdatePalette
End Sub


' ***********************************************
' Update the selected color's value.
' ***********************************************
Private Sub RedScroll_Scroll()
    If SettingColor Then Exit Sub
    RedLabel.Caption = Format$(RedScroll.Value)
    UpdatePalette
End Sub

' ***********************************************
' Select the color the user clicked on.
' ***********************************************
Private Sub SystemColors_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Integer
Dim j As Integer

    i = Y \ Dx
    j = X \ Dy
    SelectColor i, j
End Sub

' ***********************************************
' End the application. (See also the QueryUnload
' event.)
' ***********************************************
Private Sub mnuFileExit_Click()
    Unload Me
End Sub


' ***********************************************
' Allow the user to select a new color with the
' arrow keys.
' ***********************************************
Private Sub SystemColors_KeyDown(KeyCode As Integer, Shift As Integer)
Dim i As Integer
Dim j As Integer

    i = SelectedI
    j = SelectedJ

    Select Case KeyCode
        Case vbKeyDown
            i = i + 1
            If i * 16 + j >= SysPalSize Then i = 0

        Case vbKeyUp
            i = i - 1
            If i < 0 Then
                i = (SysPalSize - 1) \ 16
                If i * 16 + j >= SysPalSize Then _
                    i = i - 1
            End If

        Case vbKeyLeft
            j = j - 1
            If j < 0 Then
                j = 15
                If i * 16 + j >= SysPalSize Then _
                    j = SysPalSize - 1 - i * 16
            End If

        Case vbKeyRight
            j = j + 1
            If j > 15 Or _
                i * 16 + j >= SysPalSize Then _
                    j = 0

    End Select

    SelectColor i, j
End Sub



' ***********************************************
' Redraw the image scrolled appropriately.
' ***********************************************
Private Sub VBar_Change()
    DrawImage
End Sub


' ***********************************************
' Redraw the image scrolled appropriately.
' ***********************************************
Private Sub VBar_Scroll()
    DrawImage
End Sub